home *** CD-ROM | disk | FTP | other *** search
/ Almathera Ten Pack 3: CDPD 3 / Almathera Ten on Ten - Disc 3: CDPD3.iso / fish / 001-100 / 001-025 / 018 / xlisp1.6 / xlmath.c < prev    next >
C/C++ Source or Header  |  1995-03-17  |  11KB  |  634 lines
  1. /* xlmath - xlisp builtin arithmetic functions */
  2. /*    Copyright (c) 1985, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #ifdef MEGAMAX
  7. #include <fmath.h>
  8. overlay "math"
  9. #else
  10. #include <math.h>
  11. #endif
  12.  
  13. /*
  14.  * Lattice's math.h include declarations for fabs, so must come before
  15.  * xlisp.h
  16.  */
  17.  
  18. #include "xlisp.h"
  19.  
  20. /* external variables */
  21. extern NODE *true;
  22.  
  23. /* forward declarations */
  24. FORWARD NODE *unary();
  25. FORWARD NODE *binary();
  26. FORWARD NODE *predicate();
  27. FORWARD NODE *compare();
  28.  
  29. /* xadd - builtin function for addition */
  30. NODE *xadd(args)
  31.   NODE *args;
  32. {
  33.     return (binary(args,'+'));
  34. }
  35.  
  36. /* xsub - builtin function for subtraction */
  37. NODE *xsub(args)
  38.   NODE *args;
  39. {
  40.     return (binary(args,'-'));
  41. }
  42.  
  43. /* xmul - builtin function for multiplication */
  44. NODE *xmul(args)
  45.   NODE *args;
  46. {
  47.     return (binary(args,'*'));
  48. }
  49.  
  50. /* xdiv - builtin function for division */
  51. NODE *xdiv(args)
  52.   NODE *args;
  53. {
  54.     return (binary(args,'/'));
  55. }
  56.  
  57. /* xrem - builtin function for remainder */
  58. NODE *xrem(args)
  59.   NODE *args;
  60. {
  61.     return (binary(args,'%'));
  62. }
  63.  
  64. /* xmin - builtin function for minimum */
  65. NODE *xmin(args)
  66.   NODE *args;
  67. {
  68.     return (binary(args,'m'));
  69. }
  70.  
  71. /* xmax - builtin function for maximum */
  72. NODE *xmax(args)
  73.   NODE *args;
  74. {
  75.     return (binary(args,'M'));
  76. }
  77.  
  78. /* xexpt - built-in function 'expt' */
  79. NODE *xexpt(args)
  80.   NODE *args;
  81. {
  82.     return (binary(args,'E'));
  83. }
  84.  
  85. /* xbitand - builtin function for bitwise and */
  86. NODE *xbitand(args)
  87.   NODE *args;
  88. {
  89.     return (binary(args,'&'));
  90. }
  91.  
  92. /* xbitior - builtin function for bitwise inclusive or */
  93. NODE *xbitior(args)
  94.   NODE *args;
  95. {
  96.     return (binary(args,'|'));
  97. }
  98.  
  99. /* xbitxor - builtin function for bitwise exclusive or */
  100. NODE *xbitxor(args)
  101.   NODE *args;
  102. {
  103.     return (binary(args,'^'));
  104. }
  105.  
  106. /* binary - handle binary operations */
  107. LOCAL NODE *binary(args,fcn)
  108.   NODE *args; int fcn;
  109. {
  110.     FIXNUM ival,iarg;
  111.     FLONUM fval,farg;
  112.     NODE *arg;
  113.     int imode;
  114.  
  115.     /* get the first argument */
  116.     arg = xlarg(&args);
  117.  
  118.     /* set the type of the first argument */
  119.     if (fixp(arg)) {
  120.     ival = getfixnum(arg);
  121.     imode = TRUE;
  122.     }
  123.     else if (floatp(arg)) {
  124.     fval = getflonum(arg);
  125.     imode = FALSE;
  126.     }
  127.     else
  128.     xlerror("bad argument type",arg);
  129.  
  130.     /* treat '-' with a single argument as a special case */
  131.     if (fcn == '-' && args == NIL)
  132.     if (imode)
  133.         ival = -ival;
  134.     else
  135.         fval = -fval;
  136.  
  137.     /* handle each remaining argument */
  138.     while (args) {
  139.  
  140.     /* get the next argument */
  141.     arg = xlarg(&args);
  142.  
  143.     /* check its type */
  144.     if (fixp(arg))
  145.         if (imode) iarg = getfixnum(arg);
  146.         else farg = (FLONUM)getfixnum(arg);
  147.     else if (floatp(arg))
  148.         if (imode) { fval = (FLONUM)ival; farg = getflonum(arg); imode = FALSE; }
  149.         else farg = getflonum(arg);
  150.     else
  151.         xlerror("bad argument type",arg);
  152.  
  153.     /* accumulate the result value */
  154.     if (imode)
  155.         switch (fcn) {
  156.         case '+':    ival += iarg; break;
  157.         case '-':    ival -= iarg; break;
  158.         case '*':    ival *= iarg; break;
  159.         case '/':    checkizero(iarg); ival /= iarg; break;
  160.         case '%':    checkizero(iarg); ival %= iarg; break;
  161.         case 'M':    if (iarg > ival) ival = iarg; break;
  162.         case 'm':    if (iarg < ival) ival = iarg; break;
  163.         case '&':    ival &= iarg; break;
  164.         case '|':    ival |= iarg; break;
  165.         case '^':    ival ^= iarg; break;
  166.         default:    badiop();
  167.         }
  168.     else
  169.         switch (fcn) {
  170.         case '+':    fval += farg; break;
  171.         case '-':    fval -= farg; break;
  172.         case '*':    fval *= farg; break;
  173.         case '/':    checkfzero(farg); fval /= farg; break;
  174.         case 'M':    if (farg > fval) fval = farg; break;
  175.         case 'm':    if (farg < fval) fval = farg; break;
  176.         case 'E':    fval = pow(fval,farg); break;
  177.         default:    badfop();
  178.         }
  179.     }
  180.  
  181.     /* return the result */
  182.     return (imode ? cvfixnum(ival) : cvflonum(fval));
  183. }
  184.  
  185. /* checkizero - check for integer division by zero */
  186. checkizero(iarg)
  187.   FIXNUM iarg;
  188. {
  189.     if (iarg == 0)
  190.     xlfail("division by zero");
  191. }
  192.  
  193. /* checkfzero - check for floating point division by zero */
  194. checkfzero(farg)
  195.   FLONUM farg;
  196. {
  197.     if (farg == 0.0)
  198.     xlfail("division by zero");
  199. }
  200.  
  201. /* checkfneg - check for square root of a negative number */
  202. checkfneg(farg)
  203.   FLONUM farg;
  204. {
  205.     if (farg < 0.0)
  206.     xlfail("square root of a negative number");
  207. }
  208.  
  209. /* xbitnot - bitwise not */
  210. NODE *xbitnot(args)
  211.   NODE *args;
  212. {
  213.     return (unary(args,'~'));
  214. }
  215.  
  216. /* xabs - builtin function for absolute value */
  217. NODE *xabs(args)
  218.   NODE *args;
  219. {
  220.     return (unary(args,'A'));
  221. }
  222.  
  223. /* xadd1 - builtin function for adding one */
  224. NODE *xadd1(args)
  225.   NODE *args;
  226. {
  227.     return (unary(args,'+'));
  228. }
  229.  
  230. /* xsub1 - builtin function for subtracting one */
  231. NODE *xsub1(args)
  232.   NODE *args;
  233. {
  234.     return (unary(args,'-'));
  235. }
  236.  
  237. /* xsin - built-in function 'sin' */
  238. NODE *xsin(args)
  239.   NODE *args;
  240. {
  241.     return (unary(args,'S'));
  242. }
  243.  
  244. /* xcos - built-in function 'cos' */
  245. NODE *xcos(args)
  246.   NODE *args;
  247. {
  248.     return (unary(args,'C'));
  249. }
  250.  
  251. /* xtan - built-in function 'tan' */
  252. NODE *xtan(args)
  253.   NODE *args;
  254. {
  255.     return (unary(args,'T'));
  256. }
  257.  
  258. /* xexp - built-in function 'exp' */
  259. NODE *xexp(args)
  260.   NODE *args;
  261. {
  262.     return (unary(args,'E'));
  263. }
  264.  
  265. /* xsqrt - built-in function 'sqrt' */
  266. NODE *xsqrt(args)
  267.   NODE *args;
  268. {
  269.     return (unary(args,'R'));
  270. }
  271.  
  272. /* xfix - built-in function 'fix' */
  273. NODE *xfix(args)
  274.   NODE *args;
  275. {
  276.     return (unary(args,'I'));
  277. }
  278.  
  279. /* xfloat - built-in function 'float' */
  280. NODE *xfloat(args)
  281.   NODE *args;
  282. {
  283.     return (unary(args,'F'));
  284. }
  285.  
  286. /* xrand - built-in function 'random' */
  287. NODE *xrand(args)
  288.   NODE *args;
  289. {
  290.     return (unary(args,'R'));
  291. }
  292.  
  293. /* unary - handle unary operations */
  294. LOCAL NODE *unary(args,fcn)
  295.   NODE *args; int fcn;
  296. {
  297.     FLONUM fval;
  298.     FIXNUM ival;
  299.     NODE *arg;
  300.  
  301.     /* get the argument */
  302.     arg = xlarg(&args);
  303.     xllastarg(args);
  304.  
  305.     /* check its type */
  306.     if (fixp(arg)) {
  307.     ival = getfixnum(arg);
  308.     switch (fcn) {
  309.     case '~':    ival = ~ival; break;
  310.     case 'A':    ival = abs(ival); break;
  311.     case '+':    ival++; break;
  312.     case '-':    ival--; break;
  313.     case 'I':    break;
  314.     case 'F':    return (cvflonum((FLONUM)ival));
  315.     case 'R':    ival = (FIXNUM)osrand((int)ival); break;
  316.     default:    badiop();
  317.     }
  318.     return (cvfixnum(ival));
  319.     }
  320.     else if (floatp(arg)) {
  321.     fval = getflonum(arg);
  322.     switch (fcn) {
  323.     case 'A':    fval = fabs(fval); break;
  324.     case '+':    fval += 1.0; break;
  325.     case '-':    fval -= 1.0; break;
  326.     case 'S':    fval = sin(fval); break;
  327.     case 'C':    fval = cos(fval); break;
  328.     case 'T':    fval = tan(fval); break;
  329.     case 'E':    fval = exp(fval); break;
  330.     case 'R':    checkfneg(fval); fval = sqrt(fval); break;
  331.     case 'I':    return (cvfixnum((FIXNUM)fval));
  332.     case 'F':    break;
  333.     default:    badfop();
  334.     }
  335.     return (cvflonum(fval));
  336.     }
  337.     else
  338.     xlerror("bad argument type",arg);
  339. }
  340.  
  341. /* xminusp - is this number negative? */
  342. NODE *xminusp(args)
  343.   NODE *args;
  344. {
  345.     return (predicate(args,'-'));
  346. }
  347.  
  348. /* xzerop - is this number zero? */
  349. NODE *xzerop(args)
  350.   NODE *args;
  351. {
  352.     return (predicate(args,'Z'));
  353. }
  354.  
  355. /* xplusp - is this number positive? */
  356. NODE *xplusp(args)
  357.   NODE *args;
  358. {
  359.     return (predicate(args,'+'));
  360. }
  361.  
  362. /* xevenp - is this number even? */
  363. NODE *xevenp(args)
  364.   NODE *args;
  365. {
  366.     return (predicate(args,'E'));
  367. }
  368.  
  369. /* xoddp - is this number odd? */
  370. NODE *xoddp(args)
  371.   NODE *args;
  372. {
  373.     return (predicate(args,'O'));
  374. }
  375.  
  376. /* predicate - handle a predicate function */
  377. LOCAL NODE *predicate(args,fcn)
  378.   NODE *args; int fcn;
  379. {
  380.     FLONUM fval;
  381.     FIXNUM ival;
  382.     NODE *arg;
  383.  
  384.     /* get the argument */
  385.     arg = xlarg(&args);
  386.     xllastarg(args);
  387.  
  388.     /* check the argument type */
  389.     if (fixp(arg)) {
  390.     ival = getfixnum(arg);
  391.     switch (fcn) {
  392.     case '-':    ival = (ival < 0); break;
  393.     case 'Z':    ival = (ival == 0); break;
  394.     case '+':    ival = (ival > 0); break;
  395.     case 'E':    ival = ((ival & 1) == 0); break;
  396.     case 'O':    ival = ((ival & 1) != 0); break;
  397.     default:    badiop();
  398.     }
  399.     }
  400.     else if (floatp(arg)) {
  401.     fval = getflonum(arg);
  402.     switch (fcn) {
  403.     case '-':    ival = (fval < 0); break;
  404.     case 'Z':    ival = (fval == 0); break;
  405.     case '+':    ival = (fval > 0); break;
  406.     default:    badfop();
  407.     }
  408.     }
  409.     else
  410.     xlerror("bad argument type",arg);
  411.  
  412.     /* return the result value */
  413.     return (ival ? true : NIL);
  414. }
  415.  
  416. /* xlss - builtin function for < */
  417. NODE *xlss(args)
  418.   NODE *args;
  419. {
  420.     return (compare(args,'<'));
  421. }
  422.  
  423. /* xleq - builtin function for <= */
  424. NODE *xleq(args)
  425.   NODE *args;
  426. {
  427.     return (compare(args,'L'));
  428. }
  429.  
  430. /* equ - builtin function for = */
  431. NODE *xequ(args)
  432.   NODE *args;
  433. {
  434.     return (compare(args,'='));
  435. }
  436.  
  437. /* xneq - builtin function for /= */
  438. NODE *xneq(args)
  439.   NODE *args;
  440. {
  441.     return (compare(args,'#'));
  442. }
  443.  
  444. /* xgeq - builtin function for >= */
  445. NODE *xgeq(args)
  446.   NODE *args;
  447. {
  448.     return (compare(args,'G'));
  449. }
  450.  
  451. /* xgtr - builtin function for > */
  452. NODE *xgtr(args)
  453.   NODE *args;
  454. {
  455.     return (compare(args,'>'));
  456. }
  457.  
  458. /* compare - common compare function */
  459. LOCAL NODE *compare(args,fcn)
  460.   NODE *args; int fcn;
  461. {
  462.     NODE *arg1,*arg2;
  463.     FIXNUM icmp;
  464.     FLONUM fcmp;
  465.     int imode;
  466.  
  467.     /* get the two arguments */
  468.     arg1 = xlarg(&args);
  469.     arg2 = xlarg(&args);
  470.     xllastarg(args);
  471.  
  472.     /* do the compare */
  473.     if (stringp(arg1) && stringp(arg2)) {
  474.     icmp = strcmp(getstring(arg1),getstring(arg2));
  475.     imode = TRUE;
  476.     }
  477.     else if (fixp(arg1) && fixp(arg2)) {
  478.     icmp = getfixnum(arg1) - getfixnum(arg2);
  479.     imode = TRUE;
  480.     }
  481.     else if (floatp(arg1) && floatp(arg2)) {
  482.     fcmp = getflonum(arg1) - getflonum(arg2);
  483.     imode = FALSE;
  484.     }
  485.     else if (fixp(arg1) && floatp(arg2)) {
  486.     fcmp = (FLONUM)getfixnum(arg1) - getflonum(arg2);
  487.     imode = FALSE;
  488.     }
  489.     else if (floatp(arg1) && fixp(arg2)) {
  490.     fcmp = getflonum(arg1) - (FLONUM)getfixnum(arg2);
  491.     imode = FALSE;
  492.     }
  493.     else
  494.     xlfail("expecting strings, integers or floats");
  495.  
  496.     /* compute result of the compare */
  497.     if (imode)
  498.     switch (fcn) {
  499.     case '<':    icmp = (icmp < 0); break;
  500.     case 'L':    icmp = (icmp <= 0); break;
  501.     case '=':    icmp = (icmp == 0); break;
  502.     case '#':    icmp = (icmp != 0); break;
  503.     case 'G':    icmp = (icmp >= 0); break;
  504.     case '>':    icmp = (icmp > 0); break;
  505.     }
  506.     else
  507.     switch (fcn) {
  508.     case '<':    icmp = (fcmp < 0.0); break;
  509.     case 'L':    icmp = (fcmp <= 0.0); break;
  510.     case '=':    icmp = (fcmp == 0.0); break;
  511.     case '#':    icmp = (fcmp != 0.0); break;
  512.     case 'G':    icmp = (fcmp >= 0.0); break;
  513.     case '>':    icmp = (fcmp > 0.0); break;
  514.     }
  515.  
  516.     /* return the result */
  517.     return (icmp ? true : NIL);
  518. }
  519.  
  520. /* badiop - bad integer operation */
  521. LOCAL badiop()
  522. {
  523.     xlfail("bad integer operation");
  524. }
  525.  
  526. /* badfop - bad floating point operation */
  527. LOCAL badfop()
  528. {
  529.     xlfail("bad floating point operation");
  530. }
  531.  
  532.  
  533.  
  534.  
  535.  
  536.  
  537.  
  538.  
  539.  
  540.  
  541.  
  542.  
  543.  
  544.  
  545.  
  546.  
  547.  
  548.  
  549.  
  550.  
  551.  
  552.  
  553.  
  554.  
  555.  
  556.  
  557.  
  558.  
  559.  
  560.  
  561.  
  562.  
  563.  
  564.  
  565.  
  566.  
  567.  
  568.  
  569.  
  570.  
  571.  
  572.  
  573.  
  574.  
  575.  
  576.  
  577.  
  578.  
  579.  
  580.  
  581.  
  582.  
  583.  
  584.  
  585.  
  586.  
  587.  
  588.  
  589.  
  590.  
  591.  
  592.  
  593.  
  594.  
  595.  
  596.  
  597.  
  598.  
  599.  
  600.  
  601.  
  602.  
  603.  
  604.  
  605.  
  606.  
  607.  
  608.  
  609.  
  610.  
  611.  
  612.  
  613.  
  614.  
  615.  
  616.  
  617.  
  618.  
  619.  
  620.  
  621.  
  622.  
  623.  
  624.  
  625.  
  626.  
  627.  
  628.  
  629.  
  630.  
  631.  
  632.  
  633.  
  634.